home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / cpl.lisp < prev    next >
Lisp/Scheme  |  1990-01-25  |  11KB  |  311 lines
  1. ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; compute-class-precedence-list
  32. ;;;
  33. ;;; Knuth section 2.2.3 has some interesting notes on this.
  34. ;;; 
  35. ;;; What appears here is basically the algorithm presented there.
  36. ;;;
  37. ;;; The key idea is that we use class-precedence-description (CPD) structures
  38. ;;; to store the precedence information as we proceed.  The CPD structure for
  39. ;;; a class stores two critical pieces of information:
  40. ;;; 
  41. ;;;  - a count of the number of "reasons" why the class can't go
  42. ;;;    into the class precedence list yet.
  43. ;;;    
  44. ;;;  - a list of the "reasons" this class prevents others from
  45. ;;;    going in until after it
  46. ;;
  47. ;;; A "reason" is essentially a single local precedence constraint.  If a
  48. ;;; constraint between two classes arises more than once it generates more
  49. ;;; than one reason.  This makes things simpler, linear, and isn't a problem
  50. ;;; as long as we make sure to keep track of each instance of a "reason".
  51. ;;;
  52. ;;; This code is divided into three phases.
  53. ;;; 
  54. ;;;  - the first phase simply generates the CPD's for each of the class
  55. ;;;    and its superclasses.  The remainder of the code will manipulate
  56. ;;;    these CPDs rather than the class objects themselves.  At the end
  57. ;;;    of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
  58. ;;;    of the direct superclasses of the class.
  59. ;;;
  60. ;;;  - the second phase folds all the local constraints into the CPD
  61. ;;;    structure.  The CPD-COUNT of each CPD is built up, and the
  62. ;;;    CPD-AFTER fields are augmented to include precedence constraints
  63. ;;;    from the CPD-SUPERS field and from the order of classes in other
  64. ;;;    CPD-SUPERS fields.
  65. ;;;
  66. ;;;    After this phase, the CPD-AFTER field of a class includes all the
  67. ;;;    direct superclasses of the class plus any class that immediately
  68. ;;;    follows the class in the direct superclasses of another.  There
  69. ;;;    can be duplicates in this list.  The CPD-COUNT field is equal to
  70. ;;;    the number of times this class appears in the CPD-AFTER field of
  71. ;;;    all the other CPDs.
  72. ;;;
  73. ;;;  - In the third phase, classes are put into the precedence list one
  74. ;;;    at a time, with only those classes with a CPD-COUNT of 0 being
  75. ;;;    candidates for insertion.  When a class is inserted , every CPD
  76. ;;;    in its CPD-AFTER field has its count decremented.
  77. ;;;
  78. ;;;    In the usual case, there is only one candidate for insertion at
  79. ;;;    any point.  If there is more than one, the specified tiebreaker
  80. ;;;    rule is used to choose among them.
  81. ;;;    
  82.  
  83. (defmethod compute-class-precedence-list ((root std-class) direct-superclasses)
  84.   (compute-std-cpl root direct-superclasses))
  85.  
  86. (defstruct (class-precedence-description
  87.          (:conc-name nil)
  88.          (:print-function (lambda (obj str depth)
  89.                 (declare (ignore depth))
  90.                 (format str
  91.                     "#<CPD ~S ~D>"
  92.                     (class-name (cpd-class obj))
  93.                     (cpd-count obj))))
  94.          (:constructor make-cpd ()))
  95.   (cpd-class  nil)
  96.   (cpd-supers ())
  97.   (cpd-after  ())
  98.   (cpd-count  0))
  99.  
  100. (defun compute-std-cpl (class supers)
  101.   (cond ((null supers)                ;First two branches of COND
  102.      (list class))                ;are implementing the single
  103.     ((null (cdr supers))            ;inheritance optimization.
  104.      (cons class
  105.            (compute-std-cpl (car supers)
  106.                 (class-direct-superclasses (car supers)))))
  107.     (t
  108.      (multiple-value-bind (all-cpds nclasses)
  109.          (compute-std-cpl-phase-1 class supers)
  110.        (compute-std-cpl-phase-2 all-cpds)
  111.        (compute-std-cpl-phase-3 class all-cpds nclasses)))))
  112.  
  113. (defvar *compute-std-cpl-class->entry-table-size* 60)
  114.  
  115. (defun compute-std-cpl-phase-1 (class supers)
  116.   (let ((nclasses 0)
  117.     (all-cpds ())
  118.     (table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
  119.                 :test #'eq)))
  120.     (labels ((get-cpd (c)
  121.            (or (gethash c table)
  122.            (setf (gethash c table) (make-cpd))))
  123.          (walk (c supers)
  124.            (if (forward-referenced-class-p c)
  125.            (cpl-forward-referenced-class-error class c)
  126.            (let ((cpd (get-cpd c)))
  127.              (unless (cpd-class cpd)    ;If we have already done this
  128.                         ;class before, we can quit.
  129.                (setf (cpd-class cpd) c)
  130.                (incf nclasses)
  131.                (push cpd all-cpds)
  132.                (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
  133.                (dolist (super supers)
  134.              (walk super (class-direct-superclasses super))))))))
  135.       (walk class supers)
  136.       (values all-cpds nclasses))))
  137.  
  138. (defun compute-std-cpl-phase-2 (all-cpds)
  139.   (dolist (cpd all-cpds)
  140.     (let ((supers (cpd-supers cpd)))
  141.       (when supers
  142.     (setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
  143.     (incf (cpd-count (car supers)) 1)
  144.     (do* ((t1 supers t2)
  145.           (t2 (cdr t1) (cdr t1)))
  146.          ((null t2))
  147.       (incf (cpd-count (car t2)) 2)
  148.       (push (car t2) (cpd-after (car t1))))))))
  149.  
  150. (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
  151.   (let ((candidates ())
  152.     (next-cpd nil)
  153.     (rcpl ()))
  154.     ;;
  155.     ;; We have to bootstrap the collection of those CPD's that
  156.     ;; have a zero count.  Once we get going, we will maintain
  157.     ;; this list incrementally.
  158.     ;; 
  159.     (dolist (cpd all-cpds)
  160.       (when (zerop (cpd-count cpd)) (push cpd candidates)))
  161.  
  162.     
  163.     (loop
  164.       (when (null candidates)
  165.     ;;
  166.     ;; If there are no candidates, and enough classes have been put
  167.     ;; into the precedence list, then we are all done.  Otherwise
  168.     ;; it means there is a consistency problem.
  169.     (if (zerop nclasses)
  170.         (return (reverse rcpl))
  171.         (cpl-inconsistent-error class all-cpds)))
  172.       ;;
  173.       ;; Try to find the next class to put in from among the candidates.
  174.       ;; If there is only one, its easy, otherwise we have to use the
  175.       ;; famous RPG tiebreaker rule.  There is some hair here to avoid
  176.       ;; having to call DELETE on the list of candidates.  I dunno if
  177.       ;; its worth it but what the hell.
  178.       ;; 
  179.       (setq next-cpd
  180.         (if (null (cdr candidates))
  181.         (prog1 (car candidates)
  182.                (setq candidates ()))
  183.         (block tie-breaker              
  184.           (dolist (c rcpl)
  185.             (let ((supers (class-direct-superclasses c)))
  186.               (if (memq (cpd-class (car candidates)) supers)
  187.               (return-from tie-breaker (pop candidates))
  188.               (do ((loc candidates (cdr loc)))
  189.                   ((null (cdr loc)))
  190.                 (let ((cpd (cadr loc)))
  191.                   (when (memq (cpd-class cpd) supers)
  192.                 (setf (cdr loc) (cddr loc))
  193.                 (return-from tie-breaker cpd))))))))))
  194.       (decf nclasses)
  195.       (push (cpd-class next-cpd) rcpl)
  196.       (dolist (after (cpd-after next-cpd))
  197.     (when (zerop (decf (cpd-count after)))
  198.       (push after candidates))))))
  199.  
  200. ;;;
  201. ;;; Support code for signalling nice error messages.
  202. ;;;
  203.  
  204. (defun cpl-error (class format-string &rest format-args)
  205.   (error "While computing the class precedence list of the class ~A.~%~A"
  206.       (if (class-name class)
  207.           (format nil "named ~S" (class-name class))
  208.           class)
  209.       (apply #'format nil format-string format-args)))
  210.       
  211.  
  212. (defun cpl-forward-referenced-class-error (class forward-class)
  213.   (flet ((class-or-name (class)
  214.        (if (class-name class)
  215.            (format nil "named ~S" (class-name class))
  216.            class)))
  217.     (let ((names (mapcar #'class-or-name
  218.              (cdr (find-superclass-chain class forward-class)))))
  219.       (cpl-error class
  220.          "The class ~A is a forward referenced class.~@
  221.                   The class ~A is ~A."
  222.          (class-or-name forward-class)
  223.          (class-or-name forward-class)
  224.          (if (null (cdr names))
  225.              (format nil
  226.                  "a direct superclass of the class ~A"
  227.                  (class-or-name class))
  228.              (format nil
  229.                  "reached from the class ~A by following~@
  230.                               the direct superclass chain through: ~A~
  231.                               ~%  ending at the class ~A"
  232.                  (class-or-name class)
  233.                  (format nil
  234.                      "~{~%  the class ~A,~}"
  235.                      (butlast names))
  236.                  (car (last names))))))))
  237.  
  238. (defun find-superclass-chain (bottom top)
  239.   (labels ((walk (c chain)
  240.          (if (eq c top)
  241.          (return-from find-superclass-chain (nreverse chain))
  242.          (dolist (super (class-direct-superclasses c))
  243.            (walk super (cons super chain))))))
  244.     (walk bottom (list bottom))))
  245.  
  246.  
  247. (defun cpl-inconsistent-error (class all-cpds)
  248.   (let ((reasons (find-cycle-reasons all-cpds)))
  249.     (cpl-error class
  250.       "It is not possible to compute the class precedence list because~@
  251.        there ~A in the local precedence relations.~@
  252.        ~A because:~{~%  ~A~}."
  253.       (if (cdr reasons) "are circularities" "is a circularity")
  254.       (if (cdr reasons) "These arise" "This arises")
  255.       (format-cycle-reasons (apply #'append reasons)))))
  256.  
  257. (defun format-cycle-reasons (reasons)
  258.   (flet ((class-or-name (cpd)
  259.        (let ((class (cpd-class cpd)))
  260.          (if (class-name class)
  261.          (format nil "named ~S" (class-name class))
  262.          class))))
  263.     (mapcar
  264.       #'(lambda (reason)
  265.       (ecase (caddr reason)
  266.         (:super
  267.           (format
  268.         nil
  269.         "the class ~A appears in the supers of the class ~A"
  270.         (class-or-name (cadr reason))
  271.         (class-or-name (car reason))))
  272.         (:in-supers
  273.           (format
  274.         nil
  275.         "the class ~A follows the class ~A in the supers of the class ~A"
  276.         (class-or-name (cadr reason))
  277.         (class-or-name (car reason))
  278.         (class-or-name (cadddr reason))))))      
  279.       reasons)))
  280.  
  281. (defun find-cycle-reasons (all-cpds)
  282.   (let ((been-here ())           ;List of classes we have visited.
  283.     (cycle-reasons ()))
  284.     
  285.     (labels ((chase (path)
  286.            (if (memq (car path) (cdr path))
  287.            (record-cycle (memq (car path) (nreverse path)))
  288.            (unless (memq (car path) been-here)
  289.              (push (car path) been-here)
  290.              (dolist (after (cpd-after (car path)))
  291.                (chase (cons after path))))))
  292.          (record-cycle (cycle)
  293.            (let ((reasons ()))
  294.          (do* ((t1 cycle t2)
  295.                (t2 (cdr t1) (cdr t1)))
  296.               ((null t2))
  297.            (let ((c1 (car t1))
  298.              (c2 (car t2)))
  299.              (if (memq c2 (cpd-supers c1))
  300.              (push (list c1 c2 :super) reasons)
  301.              (dolist (cpd all-cpds)
  302.                (when (memq c2 (memq c1 (cpd-supers cpd)))
  303.                  (return
  304.                    (push (list c1 c2 :in-supers cpd) reasons)))))))
  305.          (push (nreverse reasons) cycle-reasons))))
  306.       
  307.       (dolist (cpd all-cpds)
  308.     (unless (zerop (cpd-count cpd))
  309.       (chase (list cpd))))
  310.  
  311.       cycle-reasons)))